home *** CD-ROM | disk | FTP | other *** search
Text File | 1986-06-07 | 4.2 KB | 147 lines | [TEXT/MACA] |
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
- ;;;newgraphicsobjects
- ;;;a program that demonstrates graphics and
- ;;;object-oriented programming in MacScheme 1.11
- ;;;copyright 1986, MacTutor Magazine
- ;;;written by Andrew Shalit (617) 498-6637
- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
- ;;;constructors for building points and rectangles
- ;;A point is a simple pair of coordinates : (x . y)
- (define (make-point x . y)
- (if (point? x)
- x
- (cons x (car y))))
- ;;a rectangle is a list of two points: ((x1 . y1) (x2 . y2))
- (define (make-rect first-coord . other-coords)
- (if (rectangle? first-coord)
- first-coord
- (let ((first-other (car other-coords)))
- (if (point? first-coord)
- (list first-coord
- (if (point? first-other)
- first-other
- (apply make-point other-coords)))
- (apply make-rect
- (cons (make-point
- first-coord first-other)
- (cdr other-coords)))))))
-
- ;selectors for getting coordinates out of points and rectangles
- (define (x-coord point)
- (car point))
- (define (y-coord point)
- (cdr point))
- (define (left-top rectangle)
- (car rectangle))
- (define (right-bottom rectangle)
- (cadr rectangle))
- (define (left rectangle)
- (x-coord (left-top rectangle)))
- (define (top rectangle)
- (y-coord (left-top rectangle)))
- (define (right rectangle)
- (x-coord (right-bottom rectangle)))
- (define (bottom rectangle)
- (y-coord (right-bottom rectangle)))
-
- ;;tests to determine whether something is a point or rectangle
- (define (point? object)
- (if (pair? object)
- (and (number? (car object))
- (number? (cdr object)))
- ()))
- (define (rectangle? object)
- (if (pair? object)
- (and (point? (car object))
- (point? (cadr object)))
- ()))
-
- ;functions for adding and subtracting points
- (define (add-points point1 point2)
- (cons (+ (x-coord point1) (x-coord point2))
- (+ (y-coord point1) (y-coord point2))))
- (define (subtract-points point1 point2)
- (cons (- (x-coord point1) (x-coord point2))
- (- (y-coord point1) (y-coord point2))))
-
- ;function for passing a rectangle to a graphics function
- (define (2-point-function the-function the-rectangle)
- (the-function (left the-rectangle)
- (top the-rectangle)
- (right the-rectangle)
- (bottom the-rectangle)))
-
- ;;this is your basic oval that can draw, erase, invert itself,
- ;;tell its dimensions, and receive new dimensions
- (define (make-oval . oval-definition)
- (let ((oval-definition (apply make-rect oval-definition)))
- (lambda (message)
- (if (rectangle? message)
- (set! oval-definition message)
- (case message
- (DRAW (2-point-function paint-oval oval-definition))
- (ERASE (2-point-function erase-oval oval-definition))
- (INVERT (2-point-function invert-oval oval-definition))
- (DESCRIPTION oval-definition)
- (else (error "make-oval can't handle that definition"
- message)))))))
-
- ;;a grow-oval inherits all of the features of an oval, but can
- ;;also move and change size in more interesting ways
- (define (make-grow-oval . oval-def)
- (let ((this-oval (apply make-oval oval-def)))
- (lambda (the-change . the-amount)
- (let ((old-description (this-oval 'description))
- (real-amount
- (if the-amount
- (apply make-point the-amount))))
- (this-oval
- (case the-change
- (MOVE
- (make-rect
- (add-points
- real-amount
- (left-top old-description))
- (add-points
- real-amount
- (right-bottom old-description))))
- (MOVE-TO
- (make-rect
- real-amount
- (add-points
- real-amount
- (subtract-points
- (right-bottom
- old-description)
- (left-top
- old-description)))))
- (EXPAND
- (make-rect
- (subtract-points
- (left-top old-description)
- real-amount)
- (add-points
- real-amount
- (right-bottom old-description))))
- (else the-change)))))))
-
-
- ;;;this procedure shows off some ovals
- (define (oval-sampler)
- (let ( (oval-1 (make-grow-oval 5 5 50 50))
- (oval-2 (make-grow-oval 100 20 130 40))
- (oval-3 (make-grow-oval 30 90 60 120)))
- (clear-graphics)
- (oval-1 'draw)
- (oval-2 'draw)
- (oval-3 'draw)
- (oval-1 'move 5 5)
- (oval-1 'erase)
- (oval-2 'expand 4 4)
- (oval-2 'invert)
- (oval-3 'move-to 40 60 70 90)
- (oval-3 'draw)))
-
-
-